home *** CD-ROM | disk | FTP | other *** search
/ Meeting Pearls 1 / Meeting Pearls Vol 1 (1994).iso / amok98-106 / amok98 / programminginoberon / varia.mod < prev    next >
Text File  |  1993-10-07  |  4KB  |  162 lines
  1. MODULE Varia;  
  2. (* Miscellaneous algorithms from Chapters 5 to 8 *)
  3.  
  4. IMPORT Math;
  5. CONST width = 16;  size = 128;
  6. TYPE  
  7.     NameList = ARRAY width OF ARRAY size OF CHAR;
  8.     Table = ARRAY size OF INTEGER;
  9.     RealFunct = PROCEDURE(x: REAL): REAL;
  10.  
  11.  
  12. (* Chapter 5 *)
  13.  
  14. PROCEDURE Mult(X, Y: INTEGER): INTEGER;  
  15. (* Multiplication by repeated addition, page 55 *)
  16. VAR x, z: INTEGER;
  17. BEGIN
  18.     x := X;  z := 0;
  19.     WHILE x > 0 DO  z := z + Y; x := x-1 END;
  20.     RETURN z
  21. END Mult;
  22.  
  23. PROCEDURE FastMult(X, Y: INTEGER): INTEGER;
  24. (* Fast multiplication, page 56 *)
  25. VAR x, y, z: INTEGER;
  26. BEGIN
  27.     x := X;  y := Y;  z := 0;  (* x >= 0 *)
  28.     WHILE x > 0 DO
  29.         IF ODD(x) THEN  z := z + y; x := x-1  END;
  30.         y := 2*y;  x := x DIV 2
  31.     END;
  32.     RETURN z
  33. END FastMult;
  34.  
  35. PROCEDURE Log2(x: REAL): REAL;
  36. (* Log base 2, Exercise 5.6, page 61 *)
  37. VAR a, b, s: REAL;
  38. BEGIN
  39.     a := x;  b := 1;  s := 0;
  40.     WHILE b > 0 DO
  41.         a := a*a;  b := b/2;
  42.         IF a >= 2 THEN  s := s + b;  a := a/2  END
  43.     END;
  44.     RETURN s
  45. END Log2;
  46.  
  47. PROCEDURE GCD(x, y: INTEGER): INTEGER;
  48. (* Greatest common divisor, Exercise 5.8, page 61 *)
  49. VAR r: INTEGER;
  50. BEGIN
  51.     WHILE y > 0 DO  
  52.         r := x MOD y;  x := y;  y := r 
  53.     END;
  54.     RETURN x
  55. END GCD;
  56.  
  57. PROCEDURE Bisect(f: RealFunct; x1, x2: REAL): REAL;
  58. (* Compute root of f by bisection, Exercise 5.10, page 61 *)
  59. VAR x, y: REAL;
  60. BEGIN  (* (f(x1) > 0) & (f(x2) < 0) & (x1 < x2) *)
  61.     x := (x1 + x2)/2;
  62.     WHILE (x1 < x) & (x < x2) DO  y := f(x);
  63.         IF y > 0 THEN  x1 := x  ELSE  x2 := x  END;
  64.         x := (x1 + x2)/2
  65.     END;
  66.     RETURN x
  67. END Bisect;
  68.  
  69.  
  70. (* Chaapter 6 *)
  71.  
  72. PROCEDURE ComputeRoots(a, b, c: REAL; VAR r1, r2, i1, i2: REAL);  (* page 79 *)
  73. VAR det: REAL;
  74. BEGIN
  75.     b := b/2;  det := b*b - a*c;
  76.     IF det >= 0 THEN (* real roots *)
  77.         r1 := (ABS(b) + Math.sqrt(det))/a;  
  78.         IF b >= 0 THEN r1 := -r1  END;
  79.         r2 := c/(a*r1);   i1 := 0;  i2 := 0
  80.     ELSE  (* complex roots *)
  81.         r1 := -b/a;  r2 := r1;  i1 := Math.sqrt(-det);  i2 := -i1
  82.     END
  83. END ComputeRoots;
  84.  
  85.  
  86. (* Chapter 8.2: Arrays *)
  87.  
  88. PROCEDURE MatrixMult(VAR A, B, C: ARRAY OF ARRAY OF REAL;  m, n, l: INTEGER);
  89. (* Matrix multiplication, page 118 *)
  90. VAR i, j, k: INTEGER;  s: REAL;
  91. BEGIN  i := 0;
  92.     WHILE i < m DO  j := 0;
  93.         WHILE j < n DO  k := 0;  s := 0;
  94.             WHILE k < l DO  s := s + A[i, k]*B[k, j]; INC(k)  END;
  95.             C[i, j] := s;  INC(j)
  96.         END;
  97.         INC(i)
  98.     END
  99. END MatrixMult;
  100.  
  101. PROCEDURE Search(VAR t: Table; x: INTEGER; VAR i: INTEGER);
  102. (* Binary search, page 120 *)
  103. VAR j, m: INTEGER;
  104. BEGIN
  105.     i := -1;  j := LEN(t);
  106.     WHILE  j # i + 1  DO  (* t[i] <= x < t[j] *)
  107.         m := (i + j) DIV 2;
  108.         IF  t[m] <= x  THEN  i := m  ELSE  j := m   END
  109.     END  
  110.     (* (t[i] <= x < t[j]) & (j = i + 1) *)
  111. END Search;
  112.  
  113.  
  114. (* 8.2.6 Strings and the type ARRAY n OF CHAR *)
  115.  
  116. PROCEDURE Len(x: ARRAY OF CHAR): INTEGER;  (* page 123 *)
  117. VAR j: INTEGER;
  118. BEGIN  (* there exists a k: 0 <= k < LEN(x): x[k] = 0X *)
  119.     j := 0;  
  120.     WHILE  x[j] > 0X  DO  INC(j)  END;  
  121.     RETURN j
  122. END Len;
  123.  
  124. PROCEDURE Copy(s: ARRAY OF CHAR; VAR x: ARRAY OF CHAR);  (* page 123 *)
  125. VAR j: INTEGER;
  126. BEGIN  (* Len(x) > Len(s) *)
  127.     j := 0;  
  128.     WHILE s[j] # 0X DO  x[j] := s[j]; INC(j)  END;
  129.     x[j] := 0X
  130. END Copy;
  131.  
  132. PROCEDURE Locate(VAR txt: ARRAY OF CHAR; x: ARRAY OF CHAR; VAR pos: INTEGER);
  133. (* page 125 *)
  134. VAR j, Lx, Lt: INTEGER;
  135. BEGIN  Lx := Len(x);  Lt := Len(txt);  pos := -1;
  136.     REPEAT  j := 0;  
  137.         INC(pos);
  138.         WHILE (x[j] = txt[pos + j]) & (j < Lx)  DO INC(j)  END
  139.     UNTIL (j = Lx) OR ((pos + Lx) > Lt);
  140.     IF  j < Lx  THEN pos := -1 (* pattern not found *)  END
  141. END Locate;
  142.  
  143. PROCEDURE Insert(VAR txt: ARRAY OF CHAR; x: ARRAY OF CHAR; pos: INTEGER);
  144. (* page 125 *)
  145. VAR j, Lt, Lx: INTEGER;
  146. BEGIN
  147.     Lt := Len(txt);  Lx := Len(x);
  148.     IF (Lx + Lt < LEN(txt)) & (pos >= 0) & (pos <= Lt) THEN
  149.         (* make room *)
  150.         j := Lt;
  151.         WHILE j >= pos DO  txt[j + Lx] := txt[j];  DEC(j)  END; 
  152.         (* copy pattern x after character txt[pos] *)
  153.         j := 0;  
  154.         WHILE j < Lx DO  txt[pos + j] := x[j]; INC(j)  END
  155.     END
  156. END Insert;
  157.  
  158. END Varia.    (* Copyright M. Reiser, 1992 *)
  159.  
  160.  
  161.  
  162.